home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic Graphics Programming (2nd Edition)
/
Visual Basic Graphics Programming 2nd Edition.iso
/
OldSrc
/
CH10
/
SRC
/
SURFACE1.FRM
< prev
next >
Wrap
Text File
|
1996-05-02
|
16KB
|
588 lines
VERSION 4.00
Begin VB.Form SurfaceForm
Appearance = 0 'Flat
BackColor = &H00C0C0C0&
Caption = "Surfaces"
ClientHeight = 5700
ClientLeft = 300
ClientTop = 855
ClientWidth = 9090
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 6390
KeyPreview = -1 'True
Left = 240
LinkTopic = "Form1"
ScaleHeight = 5700
ScaleWidth = 9090
Top = 225
Width = 9210
Begin VB.CheckBox ShowAxesCheck
Caption = "Show Axes"
Height = 255
Left = 7080
TabIndex = 16
Top = 3360
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Saddle"
Height = 255
Index = 8
Left = 7080
TabIndex = 15
Top = 2880
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Cone"
Height = 255
Index = 7
Left = 7080
TabIndex = 14
Top = 2520
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Holes"
Height = 255
Index = 6
Left = 7080
TabIndex = 13
Top = 2160
Width = 2055
End
Begin VB.TextBox PhiText
Height = 285
Left = 3600
TabIndex = 12
Text = "0.1570"
Top = 5400
Width = 855
End
Begin VB.TextBox ThetaText
Height = 285
Left = 2040
TabIndex = 10
Text = "0.6283"
Top = 5400
Width = 855
End
Begin VB.TextBox RText
Height = 285
Left = 480
TabIndex = 8
Text = "10"
Top = 5400
Width = 855
End
Begin VB.OptionButton Choice
Caption = "Hemisphere"
Height = 255
Index = 5
Left = 7080
TabIndex = 7
Top = 1800
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Randomized Ridges"
Height = 255
Index = 4
Left = 7080
TabIndex = 6
Top = 1440
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Ridges"
Height = 255
Index = 3
Left = 7080
TabIndex = 5
Top = 1080
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Bowl"
Height = 255
Index = 2
Left = 7080
TabIndex = 4
Top = 720
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Mounds"
Height = 255
Index = 1
Left = 7080
TabIndex = 3
Top = 360
Width = 2055
End
Begin VB.OptionButton Choice
Caption = "Splash"
Height = 255
Index = 0
Left = 7080
TabIndex = 2
Top = 0
Value = -1 'True
Width = 2055
End
Begin VB.PictureBox Pict
AutoRedraw = -1 'True
Height = 5295
Left = 0
ScaleHeight = 349
ScaleMode = 3 'Pixel
ScaleWidth = 461
TabIndex = 0
Top = 0
Width = 6975
End
Begin MSComDlg.CommonDialog LoadDialog
Left = 7080
Top = 4560
_version = 65536
_extentx = 847
_extenty = 847
_stockprops = 0
cancelerror = -1 'True
End
Begin VB.Label Label1
Caption = "Phi"
Height = 255
Index = 2
Left = 3240
TabIndex = 11
Top = 5400
Width = 375
End
Begin VB.Label Label1
Caption = "Theta"
Height = 255
Index = 1
Left = 1440
TabIndex = 9
Top = 5400
Width = 495
End
Begin VB.Label Label1
Caption = "R"
Height = 255
Index = 0
Left = 240
TabIndex = 1
Top = 5400
Width = 255
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuFileLoad
Caption = "&Load..."
Shortcut = ^L
End
Begin VB.Menu mnuFileSaveAs
Caption = "&Save As..."
Shortcut = ^A
End
Begin VB.Menu mnuFileSep
Caption = "-"
End
Begin VB.Menu mnuFileExit
Caption = "E&xit"
End
End
End
Attribute VB_Name = "SurfaceForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Location of viewing eye.
Dim EyeR As Single
Dim EyeTheta As Single
Dim EyePhi As Single
Const Dtheta = PI / 20
Const Dphi = PI / 20
Const Dr = 1
' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#
Dim Projector(1 To 4, 1 To 4) As Single
Dim ThePicture As ObjPicture
Dim ShowingParameters As Boolean
Dim ChoiceNum As Integer
' *******************************************************
' Rotate the points in the cube and draw the cube.
' *******************************************************
Private Sub DrawData(pic As Object)
Dim x As Single
Dim y As Single
Dim z As Single
Dim S(1 To 4, 1 To 4) As Single
Dim t(1 To 4, 1 To 4) As Single
Dim ST(1 To 4, 1 To 4) As Single
Dim PST(1 To 4, 1 To 4) As Single
MousePointer = vbHourglass
Refresh
' Prevent overflow errors when drawing lines
' too far out of bounds.
On Error Resume Next
' Scale and translate so it looks OK in pixels.
m3Scale S, 35, -35, 1
m3Translate t, 230, 175, 0
m3MatMultiplyFull ST, S, t
m3MatMultiplyFull PST, Projector, ST
' Transform the points.
ThePicture.ApplyFull PST
' Display the data.
pic.Cls
ThePicture.Draw pic, EyeR
pic.Refresh
' Display the viewnig parameters.
ShowViewingParameters
MousePointer = vbDefault
End Sub
Sub ShowViewingParameters()
ShowingParameters = True
RText.Text = Format$(EyeR, "0.0000")
ThetaText.Text = Format$(EyeTheta, "0.0000")
PhiText.Text = Format$(EyePhi, "0.0000")
RText.Refresh
ThetaText.Refresh
PhiText.Refresh
ShowingParameters = False
End Sub
Private Sub Choice_Click(Index As Integer)
ChoiceNum = Index
CreateData (ShowAxesCheck.value = vbChecked)
DrawData Pict
Pict.SetFocus
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyLeft
EyeTheta = EyeTheta - Dtheta
Case vbKeyRight
EyeTheta = EyeTheta + Dtheta
Case vbKeyUp
EyePhi = EyePhi - Dphi
Case vbKeyDown
EyePhi = EyePhi + Dphi
Case Else
Exit Sub
End Select
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case Asc("+")
EyeR = EyeR + Dr
Case Asc("-")
EyeR = EyeR - Dr
Case Else
Exit Sub
End Select
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub Form_Load()
' Initialize the eye position.
EyeR = 10
EyeTheta = PI * 0.2
EyePhi = PI * 0.1
' Initialize the projection transformation.
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
' Create the data.
CreateData (ShowAxesCheck.value = vbChecked)
' Project and draw the data.
Me.Show
DrawData Pict
End Sub
' ************************************************
' Create the surface.
' ************************************************
Sub CreateData(show_axes As Boolean)
Const Xmin = -5
Const Zmin = -5
Const Dx = 0.3
Const Dz = 0.3
Const NumX = -2 * Xmin / Dx
Const NumZ = -2 * Zmin / Dz
Const Amp = 0.25
Const Per = 2 * PI / 4
Const Amp2 = 1
Const Per2 = 2 * PI / 16
Const Amp3 = 2
Dim grid As ObjGrid3D
Dim axis As ObjPolyline
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim y As Single
Dim z As Single
Dim D As Single
Dim R2 As Single
Dim x1 As Single
Dim z1 As Single
Dim x2 As Single
Dim z2 As Single
MousePointer = vbHourglass
Refresh
Set ThePicture = New ObjPicture
Set grid = New ObjGrid3D
grid.SetBounds Xmin, Dx, NumX, Zmin, Dz, NumZ
ThePicture.objects.Add grid
If show_axes Then
Set axis = New ObjPolyline
ThePicture.objects.Add axis
axis.AddSegment 0, 0, 0, 5.5, 0, 0
axis.AddSegment 0, 0, 0, 0, 3, 0
axis.AddSegment 0, 0, 0, 0, 0, 5.5
End If
R2 = (Xmin + 3 * Dx) * (Xmin + 3 * Dx)
x = Xmin
For i = 1 To NumX
z = Zmin
For j = 1 To NumZ
Select Case ChoiceNum
Case 0 ' Splash.
D = Sqr(x * x + z * z)
y = Amp * Cos(3 * D)
Case 1 ' Mounds.
y = Amp * (Cos(Per * x) + Cos(Per * z))
Case 2 ' Bowl.
y = 0.2 * (x * x + z * z) - 5#
Case 3 ' Ridges.
y = Amp2 * Cos(Per2 * x) + Amp3 * Cos(Per * z) / (Abs(z) / 3 + 1)
Case 4 ' Random ridges.
y = Amp2 * Cos(Per2 * x) + Amp3 * Cos(Per * z) / (Abs(z) / 3 + 1) + Amp * Rnd
Case 5 ' Hemisphere.
D = x * x + z * z
If D >= R2 Then
y = 0
Else
y = Sqr(R2 - D)
End If
Case 6 ' Holes.
x1 = (x + Xmin / 2)
z1 = (z + Xmin / 2)
x2 = (x - Xmin / 2)
z2 = (z - Xmin / 2)
y = Amp3 - _
1 / (x1 * x1 + z1 * z1 + 0.1) - _
1 / (x2 * x2 + z1 * z1 + 0.1) - _
1 / (x1 * x1 + z2 * z2 + 0.1) - _
1 / (x2 * x2 + z2 * z2 + 0.1)
Case 7 ' Cone.
D = 2 * (Amp3 - Sqr(x * x + z * z))
If D < -Amp3 Then D = -Amp3
y = D
Case 8 ' Saddle.
y = (x * x - z * z) / 10
End Select
grid.SetValue x, y, z
z = z + Dz
Next j
x = x + Dx
Next i
MousePointer = vbDefault
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuFileLoad_Click()
Dim fname As String
Dim filenum As Integer
Dim txt As String
Dim Xmin As Single
Dim Ymin As Single
Dim xmax As Single
Dim ymax As Single
' Allow the user to pick a file.
On Error Resume Next
LoadDialog.filename = "*.APF"
LoadDialog.ShowOpen
If Err.Number = cdlCancel Then
Unload LoadDialog
Exit Sub
ElseIf Err.Number <> 0 Then
Unload LoadDialog
Beep
MsgBox "Error selecting file.", , vbExclamation
Exit Sub
End If
On Error GoTo 0
fname = LoadDialog.filename
LoadDialog.InitDir = Left$(fname, Len(fname) _
- Len(LoadDialog.FileTitle) - 1)
' Clear the picture.
Set ThePicture = Nothing
' Open the file.
filenum = FreeFile
Open fname For Input As #filenum
' Make sure it's an Object Picture File.
Input #filenum, txt
If txt <> "3D APF PICTURE" Then
Close filenum
Beep
MsgBox "Error reading file """ & fname & """.", , vbExclamation
Exit Sub
End If
' Read the picture.
Set ThePicture = New ObjPicture
ThePicture.FileInput filenum
' Close the file.
Close filenum
' Refresh the display.
DrawData Pict
' Deselect all the option buttons.
For ChoiceNum = 0 To 8
If Choice(ChoiceNum).value Then _
Choice(ChoiceNum).value = False
Next ChoiceNum
End Sub
Private Sub mnuFileSaveAs_Click()
Dim fname As String
Dim filenum As Integer
' Allow the user to pick a file.
On Error Resume Next
LoadDialog.filename = "*.APF"
LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
LoadDialog.ShowSave
If Err.Number = cdlCancel Then
Unload LoadDialog
Exit Sub
ElseIf Err.Number <> 0 Then
Unload LoadDialog
Beep
MsgBox "Error selecting file.", , vbExclamation
Exit Sub
End If
On Error GoTo 0
fname = LoadDialog.filename
LoadDialog.InitDir = Left$(fname, Len(fname) _
- Len(LoadDialog.FileTitle) - 1)
' Open the file.
filenum = FreeFile
Open fname For Output As #filenum
' Write the picture.
ThePicture.FileWrite filenum
' Close the file.
Close filenum
End Sub
Private Sub PhiText_Change()
If ShowingParameters Then Exit Sub
EyePhi = CSng(PhiText.Text)
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub RText_Change()
If ShowingParameters Then Exit Sub
EyeR = CSng(RText.Text)
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub ShowAxesCheck_Click()
CreateData (ShowAxesCheck.value = vbChecked)
DrawData Pict
Pict.SetFocus
End Sub
Private Sub ThetaText_Change()
If ShowingParameters Then Exit Sub
EyeTheta = CSng(ThetaText.Text)
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
